home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 551-575 / disk_556 / scheme2c / scheme-src.lzh / scrt / scrt7.sc < prev    next >
Text File  |  1991-10-11  |  16KB  |  478 lines
  1. ;;; SCHEME->C Runtime Library
  2.  
  3. ;*              Copyright 1989 Digital Equipment Corporation
  4. ;*                         All Rights Reserved
  5. ;*
  6. ;* Permission to use, copy, and modify this software and its documentation is
  7. ;* hereby granted only under the following terms and conditions.  Both the
  8. ;* above copyright notice and this permission notice must appear in all copies
  9. ;* of the software, derivative works or modified versions, and any portions
  10. ;* thereof, and both notices must appear in supporting documentation.
  11. ;*
  12. ;* Users of this software agree to the terms and conditions set forth herein,
  13. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  14. ;* right and license under any changes, enhancements or extensions made to the
  15. ;* core functions of the software, including but not limited to those affording
  16. ;* compatibility with other hardware or software environments, but excluding
  17. ;* applications which incorporate this software.  Users further agree to use
  18. ;* their best efforts to return to Digital any such changes, enhancements or
  19. ;* extensions that they make and inform Digital of noteworthy uses of this
  20. ;* software.  Correspondence should be provided to Digital at:
  21. ;* 
  22. ;*                       Director of Licensing
  23. ;*                       Western Research Laboratory
  24. ;*                       Digital Equipment Corporation
  25. ;*                       100 Hamilton Avenue
  26. ;*                       Palo Alto, California  94301  
  27. ;* 
  28. ;* This software may be distributed (but not offered for sale or transferred
  29. ;* for compensation) to third parties, provided such third parties agree to
  30. ;* abide by the terms and conditions of this notice.  
  31. ;* 
  32. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  33. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  34. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  35. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  36. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  37. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  38. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  39. ;* SOFTWARE.
  40.  
  41. (module scrt7 (top-level))
  42.  
  43. (define-external UNDEFINED "sc" "undefined")
  44.  
  45. (define-c-external (SSCANF pointer pointer pointer pointer) int "sscanf")
  46.  
  47. (define-c-external (GCVT double int pointer) int "gcvt")
  48.  
  49. ;;; 7.1.1.  Lexical Structure
  50.  
  51. ;;; The following global values define tokens used to denote special symbols
  52. ;;; which are returned by TOKEN.  They must be computed at run-time as they
  53. ;;; cannot use READCONSTANT.
  54.  
  55. (define TOKEN-LEFT-PAREN (cons 'left-paren '()))
  56.  
  57. (define TOKEN-RIGHT-PAREN (cons 'right-paren '()))
  58.  
  59. (define TOKEN-QUOTE (cons 'quote '()))
  60.  
  61. (define TOKEN-QUASIQUOTE (cons 'quasiquote '()))
  62.  
  63. (define TOKEN-UNQUOTE-SPLICING (cons 'unquote-splicing '()))
  64.  
  65. (define TOKEN-UNQUOTE (cons 'unquote '()))
  66.  
  67. (define TOKEN-PERIOD (cons 'period '()))
  68.  
  69. (define TOKEN-VECTOR (cons 'vector '()))
  70.  
  71. ;;; In order to read characters faster from the current input port, the
  72. ;;; methods are cached here on entry to this module by READ-DATUM.
  73.  
  74. (define PEEK-CHAR-PORT '())    ;;; Method to inspect a char
  75.  
  76. (define READ-CHAR-PORT '())    ;;; Method to read a char
  77.  
  78. (define (NEXT-CHAR)
  79.     (let ((char (read-char-port)))
  80.      (if (eof-object? char)
  81.          (error 'READ "Unexpected end-of-file")
  82.          char)))
  83.  
  84. (define-in-line (CHAR-WHITESPACE? char)
  85.     ((lap (char)
  86.       (BOOLEAN (OR (EQ char (C_CHAR "040"))
  87.                (AND (GTE char (C_CHAR "011"))
  88.                 (LTE char (C_CHAR "015")))))) char))
  89.  
  90. (define-in-line (CHAR->INTEGER c) ((lap (c) (C_FIXED (CHAR_C c))) c))
  91.  
  92. (define-in-line (SPECIAL-INITIAL? char)
  93.     (memq char '(#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\~ #\_ #\^)))
  94.  
  95. (define-in-line (SPECIAL-SUBSEQUENT? char) (memq char '(#\. #\+ #\-)))
  96.  
  97. (define (TOKEN)
  98.     (let ((char (next-char)))
  99.      (cond ((or (char-whitespace? char) (comment? char))
  100.         (token))
  101.            ((char-alphabetic? char)
  102.         (identifier (char-upcase char)))
  103.            ((char=? char #\")
  104.         (string))
  105.            ((char=? char #\()
  106.         token-left-paren)
  107.            ((char=? char #\))
  108.         token-right-paren)
  109.            ((char=? char #\')
  110.         token-quote)
  111.            ((char=? char #\`)
  112.         token-quasiquote)
  113.            ((char=? char #\,)
  114.         (if (char=? (peek-char-port) #\@)
  115.             (begin (next-char)
  116.                    token-unquote-splicing)
  117.             token-unquote))
  118.            ((char=? char #\.)
  119.         (cond ((char-numeric? (peek-char-port)) (number char 10 1))
  120.               ((char-whitespace? (peek-char-port)) token-period)
  121.               (else (identifier char))))
  122.            ((char=? char #\#)
  123.         (set! char (char-upcase (next-char)))
  124.         (cond ((char=? char #\()
  125.                token-vector)
  126.               ((char=? char #\\ )
  127.                (character))
  128.               ((char=? char #\T)
  129.                #t)
  130.               ((char=? char #\F)
  131.                #f)
  132.               ((char=? char #\B)
  133.                (number (next-char) 2 1))
  134.               ((char=? char #\O)
  135.                (number (next-char) 8 1))
  136.               ((char=? char #\D)
  137.                (number (next-char) 10 1))
  138.               ((char=? char #\X)
  139.                (number (next-char) 16 1))
  140.               (else (error 'READ "Invalid # option: ~a" char))))
  141.            ((special-initial? char)
  142.         (identifier char))
  143.            ((char=? char #\\ )
  144.         (identifier (next-char)))
  145.            ((or (eq? char '#\+) (eq? char #\-))
  146.         (let ((next (peek-char-port)))
  147.              (if (or (char-numeric? next) (memq next '(#\# #\.)))
  148.              (number char 0 0)
  149.              (identifier char))))
  150.            (else (number char 0 0)))))
  151.                                       
  152. (define (DELIMITER? char)
  153.     (or (eof-object? char)
  154.     (char-whitespace? char)
  155.     (memq char '(#\( #\) #\" #\;))))
  156.  
  157. (define (COMMENT? char)
  158.     (if (char=? char #\;)
  159.     (do () ((char=? (next-char) #\newline) #t))
  160.     #f))
  161.  
  162. ;;; When a " is detected, this function is called to read the rest of the
  163. ;;; string.
  164.  
  165. (define (STRING)
  166.     (do ((cl '() (cons char cl))
  167.      (char (next-char) (next-char)))
  168.     ((char=? char #\")
  169.      (list->string (reverse cl)))
  170.     (if (char=? #\\ char) (set! char (next-char)))))
  171.  
  172. ;;; When a #\ is detected, this function is called to read the rest of the
  173. ;;; character constant.
  174.  
  175. (define (CHARACTER)
  176.     (let ((char (next-char)))
  177.      (if (and (char-alphabetic? char)
  178.           (not (delimiter? (peek-char-port))))
  179.          (let ((id (identifier (char-upcase char))))
  180.           (case id 
  181.             ((tab)      (integer->char #o11))
  182.             ((newline)  (integer->char #o12))
  183.             ((linefeed) (integer->char #o12))
  184.             ((formfeed) (integer->char #o14))
  185.             ((return)   (integer->char #o15))
  186.             ((space)    (integer->char #o40))
  187.             (else (error 'READ "Unrecognized CHARACTER NAME: ~s"
  188.                      id))))
  189.          char)))
  190.  
  191. ;;; When the start of an identifier is detected, the following function is
  192. ;;; called to finish reading it.  It is table driven from the IDTABLE which
  193. ;;; contains an entry for each possible character.  The entries are:
  194. ;;;
  195. ;;;    #f    character is not part of the identifier.
  196. ;;;    newchar    character is part of the identifier and "newchar" is the
  197. ;;;         upshifted value.
  198. ;;;    #t    character is \ so the following character is taken as is.
  199.  
  200. (define IDTABLE
  201.     (let ((tab (make-vector 256 #f)))
  202.      (do ((i (char->integer #\A) (+ i 1))
  203.           (last (char->integer #\Z)))
  204.          ((> i last))
  205.          (vector-set! tab i (integer->char i))
  206.          (vector-set! tab (+ i 32) (integer->char i)))
  207.      (for-each
  208.          (lambda (c)
  209.              (vector-set! tab (char->integer c) c))
  210.          '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
  211.                     ; Numeric characters.
  212.            #\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\~ #\_ #\^
  213.                            ; Special initial.
  214.            #\. #\+ #\-))        ; Special subsequent.
  215.      (vector-set! tab (char->integer #\\) #t)
  216.      tab))
  217.  
  218. (define (IDENTIFIER firstchar)
  219.     (let loop ((cl (list firstchar)))
  220.      (let* ((pc (peek-char-port))
  221.         (tc (and (char? pc)
  222.              (vector-ref idtable (char->integer pc)))))
  223.            (cond ((char? tc)
  224.               (read-char-port)
  225.               (loop (cons tc cl)))
  226.              (tc
  227.               (read-char-port)
  228.               (loop (cons (next-char) cl)))
  229.              (else
  230.               (string->symbol (list->string (reverse cl))))))))
  231.  
  232. ;;; When the start of a number is detected, the following function is called
  233. ;;; to finish reading it.
  234.  
  235. (define (NUMBER firstchar base sign)
  236.     (if (zero? sign)
  237.     (cond ((char=? firstchar #\+)
  238.            (set! sign 1)
  239.            (set! firstchar (next-char)))
  240.           ((char=? firstchar #\-)
  241.            (set! sign -1)
  242.            (set! firstchar (next-char)))
  243.           (else (set! sign 1))))
  244.     (if (zero? base)
  245.     (cond ((char=? firstchar #\#)
  246.            (let ((char (next-char)))
  247.             (case char
  248.               ((#\B #\b) (set! base 2))
  249.               ((#\O #\o) (set! base 8))
  250.               ((#\D #\d) (set! base 10))
  251.               ((#\X #\x) (set! base 16))
  252.               (else (error 'READ "Invalid number base: ~a" char))))
  253.            (set! firstchar (next-char)))
  254.           (else (set! base 10))))
  255.     (do ((cl (list firstchar) (cons char cl))
  256.      (char (peek-char-port) (peek-char-port))
  257.      (bv (case firstchar ((#\0) 0) ((#\1) 1) (else -1))
  258.          (case char ((#\0) (* bv 2)) (( #\1) (+ (* bv 2) 1)) (else -1)))
  259.      (iv (accv 0.0 base firstchar) (accv iv base char))
  260.      (maxchar (char->integer firstchar) (max maxchar (char->integer char)))
  261.      (result (make-string 8))
  262.      (pad    (make-string 4))
  263.      (cs 0)
  264.      (fpt (eq? firstchar #\.)
  265.           (or fpt
  266.           (eq? char #\.)
  267.           (and (not (= base 16)) (or (eq? char #\e) (eq? char #\E))))))
  268.     ((delimiter? char)
  269.      (set! cl (list->string (reverse cl)))
  270.      (set! cs (string-append (if (eq? sign -1) "-" "") cl ")0"))
  271.      (cond (fpt
  272.         (if (not (eq? base 10))
  273.             (error 'READ "Floating point numbers must be base 10: ~a"
  274.                cl))
  275.         (if (eq? 2 (sscanf cs "%f)%d" result pad))
  276.             (c-double-ref result 0)
  277.             (error 'READ "Illegal floating point number: ~a" cl)))
  278.            ((eq? iv -1)
  279.         (error 'READ "Illegal digit(s) in integer: ~a" cl))
  280.            (else (let ((siv (* sign iv)))
  281.               (if (or (< siv minintf) (> siv maxintf))
  282.                   siv
  283.                   (float->fixed siv))))))
  284.     (next-char)))
  285.  
  286. (define (ACCV value base char)
  287.     (let ((cv (assq char '((#\0 0)  (#\1 1)  (#\2 2)  (#\3 3)
  288.                (#\4 4)  (#\5 5)  (#\6 6)  (#\7 7)
  289.                (#\8 8)  (#\9 9)  (#\a 10) (#\b 11)
  290.                (#\c 12) (#\d 13) (#\e 14) (#\f 15)
  291.                (#\A 10) (#\B 11) (#\C 12) (#\D 13)
  292.                (#\E 14) (#\F 15)))))
  293.      (if (or (eq? value -1) (not cv) (>= (cadr cv) base))
  294.          -1
  295.          (+ (* base value) (cadr cv)))))
  296.  
  297. ;;; 7.1.2. External Representations
  298.  
  299. (define (READ-DATUM port-proc)
  300.     (let ((save-peek-char-port peek-char-port)
  301.       (save-read-char-port read-char-port))
  302.      (set! peek-char-port (port-proc 'peek-char))
  303.      (set! read-char-port (port-proc 'read-char))
  304.      (let ((result (let loop ((char (peek-char-port)))
  305.                 (cond ((eof-object? char)
  306.                    (read-char-port))
  307.                   ((char-whitespace? char)
  308.                    (read-char-port)
  309.                    (loop (peek-char-port)))
  310.                   ((char=? char #\;)
  311.                    (do () ((char=? (next-char) #\newline)))
  312.                    (loop (peek-char-port)))
  313.                   (else (datum (token)))))))
  314.           (set! peek-char-port save-peek-char-port)
  315.           (set! read-char-port save-read-char-port)
  316.           result)))
  317.  
  318. (define (DATUM current-token)
  319.     (cond ((eq? current-token token-left-paren)
  320.        (datum-list (token)))
  321.       ((eq? current-token token-vector)
  322.        (list->vector (datum-vector (token))))
  323.       ((eq? current-token token-quote)
  324.        (list 'quote (datum (token))))
  325.       ((eq? current-token token-quasiquote)
  326.        (list 'quasiquote (datum (token))))
  327.       ((eq? current-token token-unquote)
  328.        (list 'unquote (datum (token))))
  329.       ((eq? current-token token-unquote-splicing)
  330.        (list 'unquote-splicing (datum (token))))
  331.       ((not (pair? current-token))
  332.        current-token)
  333.       (else (error 'READ "Poorly formed DATUM: ~s" current-token))))
  334.  
  335. (define (DATUM-LIST current-token)
  336.     (cond ((eq? current-token token-right-paren)
  337.        '())
  338.       ((eq? current-token token-period)
  339.        (let ((result (datum (token))))
  340.         (if (eq? (token) token-right-paren)
  341.             result
  342.             (error 'READ "Poorly formed LIST"))))
  343.       (else
  344.        (cons (datum current-token) (datum-list (token))))))
  345.  
  346. (define (DATUM-VECTOR current-token)
  347.     (cond ((eq? current-token token-right-paren)
  348.            '())
  349.           (else
  350.            (cons (datum current-token)
  351.          (datum-vector (token))))))
  352.  
  353. ;;; Method for printing a token is cached here.
  354.  
  355. (define WRITE-TOKEN-PORT '())
  356.  
  357. (define (WRITE/DISPLAY obj readable port-proc)
  358.     (let ((save-write-token-port write-token-port))
  359.      (set! write-token-port (port-proc 'write-token))
  360.      (let ((result (write/display2 obj readable)))
  361.           (set! write-token-port save-write-token-port)
  362.           result)))
  363.  
  364. (define (WRITE/DISPLAY2 obj readable)
  365.     (cond ((pair? obj)
  366.        (let ((qq (and (pair? (cdr obj)) (null? (cddr obj))
  367.               (assq (car obj)
  368.                 '((quote "'") (quasiquote "`")
  369.                   (unquote ",") (unquote-splicing ",@"))))))
  370.         (cond ((and qq readable) 
  371.                (write-token-port (cadr qq))
  372.                (write/display2 (cadr obj) readable))
  373.               (else
  374.                (write-token-port "(")
  375.                (write/display2 (car obj) readable)
  376.                (write/display-list (cdr obj) readable)))))
  377.       ((symbol? obj)
  378.        (if readable
  379.            (if (memq obj '(+ - ))
  380.                (write-token-port (symbol->string obj))
  381.                (write-token-port (readable-symbol obj)))
  382.            (write-token-port (symbol->string obj))))
  383.       ((fixed? obj)
  384.        (write-token-port (fixed->clist obj)))
  385.       ((string? obj)
  386.        (write-token-port (if readable (readable-string obj) obj)))
  387.       ((char? obj)
  388.        (write-token-port (if readable (readable-char obj) obj)))
  389.       ((or (string? obj) (char? obj))
  390.        (write-token-port obj))
  391.       ((vector? obj)
  392.        (write-token-port "#")
  393.        (write/display2 (vector->list obj) readable))
  394.       ((float? obj)
  395.        (write-token-port (float->clist obj)))
  396.       ((eq? obj #t)
  397.        (write-token-port "#T"))
  398.       ((eq? obj #f)
  399.        (write-token-port "#F"))
  400.       ((null? obj)
  401.        (write-token-port "()"))
  402.       ((eof-object? obj)
  403.        (write-token-port "#*END-OF-FILE*"))
  404.       ((eq? obj undefined)
  405.        (write-token-port "#*UNDEFINED*"))
  406.       ((procedure? obj)
  407.        (write-token-port "#*PROCEDURE*"))
  408.       (else (write-token-port "#*??????*"))))
  409.  
  410. (define (WRITE/DISPLAY-LIST obj readable)
  411.     (cond ((null? obj)
  412.        (write-token-port ")"))
  413.       ((not (pair? obj))
  414.        (write-token-port " . ")
  415.        (write/display2 obj readable)
  416.        (write-token-port ")"))
  417.       (else
  418.        (write-token-port " ")
  419.        (write/display2 (car obj) readable)
  420.        (write/display-list (cdr obj) readable))))
  421.  
  422. (define (READABLE-CHAR obj)
  423.     (if (and (char>? obj #\space) (char<=? obj #\~))
  424.     (list->string (list #\# #\\ obj))
  425.     (let ((spec (assoc obj '((#\tab      "#\\tab")
  426.                  (#\newline  "#\\newline")
  427.                  (#\linefeed "#\\linefeed")
  428.                  (#\formfeed "#\\formfeed")
  429.                  (#\return   "#\\return")
  430.                  (#\space    "#\\space")))))
  431.          (if spec
  432.          (cadr spec)
  433.          "#\\???"))))
  434.  
  435. (define (READABLE-STRING obj) 
  436.     (do ((cl '(#\") (cons (string-ref obj i) cl))
  437.      (len (string-length obj))
  438.      (i 0 (+ i 1)))
  439.     ((= len i) (reverse (cons #\" cl)))
  440.     (if (and (or (eq? (string-ref obj i) #\\ )
  441.              (eq? (string-ref obj i) #\" )))
  442.         (set! cl (cons #\\ cl)))))
  443.  
  444. (define (READABLE-SYMBOL obj)
  445.     (set! obj (symbol->string obj))
  446.     (do ((cl '() (cons (string-ref obj i) cl))
  447.      (len (string-length obj))
  448.      (i 0 (+ 1 i)))
  449.     ((= i len) (reverse cl))
  450.     (let ((c (string-ref obj i)))
  451.          (cond ((and (not (and (char-alphabetic? c) (char-upper-case? c)))
  452.              (not (special-initial? c))
  453.              (not (special-subsequent? c))
  454.              (not (char-numeric? c)))
  455.             (set! cl (cons #\\ cl)))
  456.            ((and (zero? i) (not (char-alphabetic? c))
  457.              (not (special-initial? c)))
  458.             (set! cl (cons #\\ cl)))))))
  459.  
  460. (define (FIXED->CLIST obj)
  461.     (do ((cl '() (cons (integer->char (+ (char->integer #\0)
  462.                      (abs (remainder number 10))))
  463.                cl))
  464.      (number obj (quotient number 10)))
  465.     ((and (zero? number) cl)
  466.      (if (< obj 0) (cons #\- cl) cl))))
  467.  
  468. (define (FLOAT->CLIST obj)
  469.     (let* ((null (integer->char 0))
  470.        (buffer (make-string 30 null)))
  471.       (gcvt obj 16 buffer)
  472.       (let loop ((cli (string->list buffer)) (clo '())) 
  473.            (if (eq? (car cli) null)
  474.            (reverse (if (or (memq #\. clo) (memq #\e clo))
  475.                 clo
  476.                 (cons #\. clo)))
  477.            (loop (cdr cli) (cons (car cli) clo))))))
  478.